
(defun histogram-plot
(&optional data &key (ok-var-types '(numeric)) 
             variable-labels  
             (show t) (top-most t) (linked t) 
             (location '(50 50)) (size '(320 320))
             (title "HistoGram Plot") 
             (legend1 (send $ :name)) (legend2 nil) 
             ;following dont work
             (content-only nil)  (go-away t)
             ;do not use menu-item, menu, in, in?, in??, or in???
             ;all are reserved for system use 
             (menu-item nil) (menu t)
             (in nil in??) (in? nil in???))

"HISTOGRAM-PLOT makes linkable histograms from frequencies calculated from raw data. 

ARGUMENTS:
&optional data &key (ok-var-types '(numeric )) (title \"Linkable Histogram\") (in nil in?) (show t)  variable-labels point-labels (legend1 (send $ :name)) (legend2 \"Plot Title\")  (location '(50 50)) (size '(320 320)) (go-away t) (content-only nil) (help-bar nil) (pop-up t))


GENERAL PLOT ARGUMENTS:
DATA may be nil, an object, a list, a vector, a list of lists, a list of vectors, or a matrix. If not specified, DATA is assumed to be and is converted to a list of vectors, one vector for each of the OK-VAR-TYPES variables in the current-data. Plot is of the first variable, initially, with the other variables available for plotting. The plot appears (or is prepared to appear if SHOW is NIL) in container IN, where IN is *DEFAULT-GRAPHICS-CONTAINER* if IN is not specified, the \"desktop\" if IN is T (i.e., popped out of *DEFAULT-GRAPHICS-CONTAINER*), the XLispStat window if IN is specified to be NIL, and container C if IN is specified to be the container window C. The plot will include variable-labels and legends, as specified. The plot will have a close box which will be de-activated when GO-AWAY is T. When CONTENT-ONLY is T the button bars, legends and overlays do not appear. When HELP-BAR is NIL the help-bar does not appear. When POP-UP is NIL the pop-up menus are not available."
      
  (let* ((actcon *active-container*)
         (in? (if in??? in? in??))
         (graph-frame (graph-frame :show nil))
         (pop-out (send graph-frame :seen-in in in?))
         (container (if (equal pop-out t) graph-frame pop-out))
         (graph-data (before-new-plot data ok-var-types ))
         (data-object (when (= 4 (length graph-data)) (fourth graph-data)))
         (linkable t)
         (graph))
    (unless variable-labels (setf variable-labels (second graph-data)))
    (setf graph-data (first graph-data))
    (unless legend2 (setf legend2 title))
    (setf graph (send histogram-plot-proto
                      :new (length graph-data)
                      :data graph-data 
                      :variable-labels variable-labels
                      :title title
                      :location location
                      :size size 
                      :go-away go-away 
                      :show t 
                      :legend1 legend1 
                      :legend2 legend2
                      :top-most top-most
                      :container container
                      :content-only content-only))
    (when graph
          (send graph :legend1 
                (if data-object (send data-object :name)
                    "Unnamed Data"))
          (send graph :title (strcat title " [" (send graph :legend1) "]"))
          (send graph :after-new-plot 
                pop-out top-most show size container linkable data-object)
          
          (send graph :show-new-var "X" 
                (first (send (send graph :data-object) :variables)))
          (setf *graph* graph))
    graph))
    

(defproto histogram-plot-proto 
  '(container legend1 legend2 legend3L legend3R) () histogram-proto)
    
(defmeth histogram-plot-proto :container (&optional (object nil set))
  (if set (setf (slot-value 'container) object))
  (slot-value 'container))
     
(defmeth histogram-plot-proto :legend1 (&optional (string nil set))
          (if set (setf (slot-value 'legend1) string))
          (slot-value 'legend1))
        
(defmeth histogram-plot-proto :legend2 (&optional (string nil set))
          (if set (setf (slot-value 'legend2) string))
          (slot-value 'legend2))
        
(defmeth histogram-plot-proto :legend3L (&optional (string nil set))
          (if set (setf (slot-value 'legend3L) string))
          (slot-value 'legend3L))
        
(defmeth histogram-plot-proto :legend3R (&optional (string nil set))
          (if set (setf (slot-value 'legend3R) string))
          (slot-value 'legend3R))

;(defmeth histogram-plot-proto :menu-template ()
;  '(help dash new-x dash
;         link mouse resize-brush dash
;         erase-selection focus-on-selection view-selection show-all dash 
;         color dash selection slicer dash
;         show-plots hide-plots close-plots dash
;         print save copy))

(defmeth histogram-plot-proto :draw-frequencies ()
  (let* ((margin (send self :margin))
         (cr (send self :content-rect))
         (height (send self :canvas-height))
         (nums (round (rseq 0 (ceiling (* 1.2 (max (send self :bin-counts)))) 7)))
         (locs (reverse (round (rseq (second (send self :content-rect))
                            (+ (second (send self :content-rect))
                               (fourth (send self :content-rect)))
                            7))))
         )
    (send self :draw-color 'white)
    (send self :paint-rect 
          (+ (select margin 0) 22)
          (select margin 1) 
          13 
          (- height (fourth margin)))
    (send self :paint-rect 
          (+ (select margin 0) 45)
          (select cr 1) 
          4 
          (select cr 3))
    (send self :draw-color 'black)
    (mapcar #'(lambda (i)
                (send self :draw-line 49 (select locs i) 45 (select locs i))
                (send self :draw-text-up 
                      (format nil "~a" (select nums i))
                      (+ (select margin 0) 22)
                      (select locs i)
                      1 1))
            (iseq 7))
    ))

(defmeth histogram-plot-proto :add-grid ()
         (let* ((cv (send self :content-variables))
                (rangex (send self :range (first cv)))
                (rangey (send self :range (second cv)))
                (minx (first  rangex))
                (maxx (second rangex))
                (miny (first  rangey))
                (maxy (second rangey))
                (line1start (- (send self :real-to-canvas minx maxy) (list 1 6)))
                (line1end   (- (send self :real-to-canvas maxx maxy) (list 0 6)))
                (line2start (send self :real-to-canvas maxx miny))
                (line2end   (- (send self :real-to-canvas maxx maxy) (list 0 6)))
                (line3start (- (send self :real-to-canvas minx maxy) (list 1 6)))
                (line3end   (- (send self :real-to-canvas minx maxy) (list 1 -1)))
                )
           (when (and line1start line1end line2start line2end)
                 (apply #'send self :draw-line 
                        (combine line1start line1end))
                 (apply #'send self :draw-line 
                        (combine line2start line2end))
                 (apply #'send self :draw-line 
                        (combine line3start line3end)))))


(defmeth histogram-plot-proto :draw-legends ()
  (let* ((line1 (+ (second (send self :margin)) -3
                   (send self :text-ascent) (send self :text-descent)))
         (line2 (+ line1
                   (send self :text-ascent) (send self :text-descent) 1))
         (line3 (- (send self :canvas-height) 3
                   (send self :text-ascent) (send self :text-descent)))
         )
    (when (send self :legend1)
          (send self :draw-text (send self :legend1)
                (floor (/ (first (send self :size)) 2)) line1 1 0))
    (when (send self :legend2)
          (send self :draw-text (send self :legend2)
                (floor (/ (first (send self :size)) 2)) line2 1 0))
    (when (send self :legend3L)
          (send self :draw-text (send self :legend3L) 3 line3 0 1))
    (when (send self :legend3R)
          (send self :draw-text (send self :legend3R) 
                (- (send self :canvas-width) 3) line3 2 1))
    ))

    
(defmeth histogram-plot-proto :redraw-content ()
  (call-next-method)
  (unless (= 0 (send self :num-points))
          (send self :draw-color 'black)
          (send self :draw-legends)
          (send self :add-grid)
          (send self :draw-frequencies))
  t)
                                                                                                                                                                                                                                                                
(defmeth histogram-plot-proto :isnew 
  (ndim &key (data nil) (show nil) variable-labels (title "Histogram Plot")
        location (size (list 250 250)) (go-away t) 
        legend1 (legend2 "Histogram Plot")
        (top-most nil) container content-only)
  (let ((graph (call-next-method ndim 
                :show show :variable-labels variable-labels
                :location location :size size 
                :go-away go-away :top-most top-most
                :legend1 legend1 :legend2 legend2 
                :container container)))
    (send graph :add-points data)
    (send graph :use-color t)
    (send graph :plot-buttons :new-x t :new-y nil :free nil :density t)
    (send graph :point-color (iseq (send graph :num-points)) 'blue)
    (send graph :mouse-mode 'brushing)
    (send graph :variable-label 
          (1- (send graph :num-variables)) "Bin Frequency")
    (send graph :y-axis t t 7)
    (send graph :range 
          (1- (send graph :num-variables)) 
          0 
          (ceiling (* 1.2 (max (send graph :bin-counts)))))
    (send graph :title title)
    graph))




(defmeth histogram-plot-proto :new (&rest args)

  (defmeth self :normal-curve-color (&optional (symbol nil set))
    (unless (send self :has-slot 'normal-curve-color)
            (send self :add-slot 'normal-curve-color))
    (if set (setf (slot-value 'normal-curve-color ) symbol))
    (slot-value 'normal-curve-color ))
  
  (defmeth self :kernel-curve-color (&optional (symbol nil set))
    (unless (send self :has-slot 'kernel-curve-color)
            (send self :add-slot 'kernel-curve-color))
    (if set (setf (slot-value 'kernel-curve-color ) symbol))
    (slot-value 'kernel-curve-color ))
  
  (defmeth self :show-normal (&optional (logical nil set))
    (unless (send self :has-slot 'show-normal)
            (send self :add-slot 'show-normal))
    (if set (setf (slot-value 'show-normal) logical))
    (slot-value 'show-normal))
  
  (defmeth self :show-kernel (&optional (logical nil set))
    (unless (send self :has-slot 'show-kernel)
            (send self :add-slot 'show-kernel))
    (if set (setf (slot-value 'show-kernel) logical))
    (slot-value 'show-kernel))
  
  (defmeth self :show-density (&optional (logical nil set))
    (unless (send self :has-slot 'show-density)
            (send self :add-slot 'show-density))
    (if set (setf (slot-value 'show-density) logical))
    (slot-value 'show-density))
  
  (defmeth self :kernel-type (&optional (logical nil set))
    (unless (send self :has-slot 'kernel-type)
            (send self :add-slot 'kernel-type))
    (if set (setf (slot-value 'kernel-type) logical))
    (slot-value 'kernel-type))

  (defmeth self :max-normal-pixel (&optional (logical nil set))
    (unless (send self :has-slot 'max-normal-pixel)
            (send self :add-slot 'max-normal-pixel))
    (if set (setf (slot-value 'max-normal-pixel) logical))
    (slot-value 'max-normal-pixel))
  
  (defmeth self :slider (&optional (logical nil set))
    (unless (send self :has-slot 'slider)
            (send self :add-slot 'slider))
    (if set (setf (slot-value 'slider) logical))
    (slot-value 'slider))
  
  (defmeth self :dens-dialog (&optional (logical nil set))
    (unless (send self :has-slot 'dens-dialog)
            (send self :add-slot 'dens-dialog))
    (if set (setf (slot-value 'dens-dialog) logical))
    (slot-value 'dens-dialog))
  
  (let ((object (apply #'call-next-method args)))
  
    (defmeth object :switch-add-normal 
      (&key (color 'red) (kcolor 'green) line-width (draw t))
      (send object :show-normal (not (send object :show-normal)))
      (cond
        ((send object :show-normal)
         (send object :add-normal
               :draw draw 
               :color 'red ;(send object :normal-curve-color)
               :line-width line-width))
        (t
         (send object :clear-lines)
         (when (send object :show-kernel) 
               (send object :add-kernel 
                     (send object :kernel-type) 
                     :draw draw
                     :color 'green ;(send object :kernel-curve-color)
                     :line-width line-width)))))
    
    (defmeth object :switch-add-kernel (&key (color 'red) line-width (draw t))
      (send object :show-kernel (not (send object :show-kernel)))
      (cond 
        ((send object :show-kernel)
         (send object :add-kernel 
               (send object :kernel-type) 
               :draw draw
               :color 'green ;(send object :kernel-curve-color) 
               :line-width line-width))
        (t
         (send object :clear-lines)
         (when (send object :show-normal) 
               (send object :add-normal 
                     :draw draw
                     :color 'red ;(send object :normal-curve-color) 
                     :line-width line-width)))))

    ;(send object :show-new-var "X" (select (send object :variable-labels) 0))

    object))



(defmeth histogram-plot-proto :show-new-var (axis variable)
  (let* ((slider (send self :slider))
         (var-num (position variable (send self :variable-labels) :test #'equal)))
    (send self :clear-lines :draw nil)
    (send self :content-variables var-num (- (send self :num-variables) 1))
    (send self :adjust-to-data)
    (when slider (send slider :value (- (send self :num-bins) 2)))
    (when (send self :show-normal) (send self :add-normal))
    (when (send self :show-kernel) 
          (send self :add-kernel (send self :kernel-type)))))
